home *** CD-ROM | disk | FTP | other *** search
- VERSION 4.00
- Begin VB.Form EnlargeForm
- Caption = "Enlarge"
- ClientHeight = 4650
- ClientLeft = 420
- ClientTop = 1185
- ClientWidth = 8955
- Height = 5340
- Left = 360
- LinkTopic = "Form1"
- ScaleHeight = 310
- ScaleMode = 3 'Pixel
- ScaleWidth = 597
- Top = 555
- Width = 9075
- Begin VB.PictureBox Pict
- AutoRedraw = -1 'True
- BackColor = &H00C0C0C0&
- Height = 4440
- Index = 2
- Left = 6000
- Picture = "ENLARGEF.frx":0000
- ScaleHeight = 292
- ScaleMode = 3 'Pixel
- ScaleWidth = 192
- TabIndex = 2
- Top = 0
- Width = 2940
- End
- Begin VB.PictureBox Pict
- AutoRedraw = -1 'True
- BackColor = &H00C0C0C0&
- Height = 4440
- Index = 1
- Left = 3000
- Picture = "ENLARGEF.frx":0446
- ScaleHeight = 292
- ScaleMode = 3 'Pixel
- ScaleWidth = 192
- TabIndex = 1
- Top = 0
- Width = 2940
- End
- Begin VB.PictureBox Pict
- AutoRedraw = -1 'True
- BackColor = &H00C0C0C0&
- Height = 4440
- Index = 0
- Left = 0
- Picture = "ENLARGEF.frx":088C
- ScaleHeight = 292
- ScaleMode = 3 'Pixel
- ScaleWidth = 192
- TabIndex = 0
- Top = 0
- Width = 2940
- End
- Begin MSComDlg.CommonDialog FileDialog
- Left = 2760
- Top = 4200
- _Version = 65536
- _ExtentX = 847
- _ExtentY = 847
- _StockProps = 0
- CancelError = -1 'True
- End
- Begin VB.Label Label1
- Alignment = 2 'Center
- Caption = "EnlargePicture Subroutine"
- Height = 255
- Index = 2
- Left = 6000
- TabIndex = 5
- Top = 4440
- Width = 2940
- End
- Begin VB.Label Label1
- Alignment = 2 'Center
- Caption = "PaintPicture Method"
- Height = 255
- Index = 1
- Left = 3000
- TabIndex = 4
- Top = 4440
- Width = 2940
- End
- Begin VB.Label Label1
- Alignment = 2 'Center
- Caption = "Original Image"
- Height = 255
- Index = 0
- Left = 0
- TabIndex = 3
- Top = 4440
- Width = 2940
- End
- Begin VB.Menu mnuFile
- Caption = "&File"
- Begin VB.Menu mnuFileLoad
- Caption = "&Load..."
- Shortcut = ^L
- End
- Begin VB.Menu mnuFileSep
- Caption = "-"
- End
- Begin VB.Menu mnuFileExit
- Caption = "E&xit"
- End
- End
- Begin VB.Menu mnuScaleMnu
- Caption = "&Scale"
- Enabled = 0 'False
- Begin VB.Menu mnuScale
- Caption = "&2x"
- Checked = -1 'True
- Index = 2
- End
- Begin VB.Menu mnuScale
- Caption = "&3x"
- Index = 3
- End
- Begin VB.Menu mnuScale
- Caption = "&4x"
- Index = 4
- End
- Begin VB.Menu mnuScale
- Caption = "&8x"
- Index = 8
- End
- Begin VB.Menu mnuScale
- Caption = "&16x"
- Index = 16
- End
- End
- Attribute VB_Name = "EnlargeForm"
- Attribute VB_Creatable = False
- Attribute VB_Exposed = False
- Option Explicit
- Dim SysPalSize As Integer
- Dim NumStaticColors As Integer
- Dim StaticColor1 As Integer
- Dim StaticColor2 As Integer
- Dim LogPal As Integer
- Dim palentry(0 To 255) As PALETTEENTRY
- Dim wid As Long
- Dim hgt As Long
- Dim bytes() As Byte
- Dim ScaleFactor As Integer
- ' ************************************************
- ' Draw the enlarged images at the proper scale.
- ' ************************************************
- Sub DrawImages()
- Dim wid As Single
- Dim hgt As Single
- Dim x0 As Single
- Dim y0 As Single
- Dim i As Integer
- WaitStart
-
- ' Enlarge using PaintPicture.
- wid = ScaleFactor * Pict(0).ScaleWidth
- hgt = ScaleFactor * Pict(0).ScaleHeight
- x0 = (Pict(1).ScaleWidth - wid) / 2
- y0 = (Pict(1).ScaleHeight - hgt) / 2
- Pict(1).PaintPicture Pict(0).Image, _
- x0, y0, wid, hgt
- DoEvents
- ' Enlarge using EnlargePicture.
- wid = Pict(0).ScaleWidth / ScaleFactor
- hgt = Pict(0).ScaleHeight / ScaleFactor
- x0 = (Pict(0).ScaleWidth - wid) / 2
- y0 = (Pict(0).ScaleHeight - hgt) / 2
- EnlargePicture Pict(0), Pict(2), _
- x0, y0, x0 + wid - 2, y0 + hgt - 2, _
- 0, 0, _
- Pict(2).ScaleWidth - 2, _
- Pict(2).ScaleHeight - 2
- DoEvents
- ' Let each image repair its palette if needed.
- For i = 0 To 2
- Pict(i).ZOrder
- DoEvents
- Next i
- WaitEnd
- End Sub
- ' ************************************************
- ' Enlarge the picture in from_pic and place it
- ' in to_pic.
- ' ************************************************
- Sub EnlargePicture( _
- ByVal from_pic As Control, ByVal to_pic As Control, _
- ByVal fx1 As Integer, ByVal fy1 As Integer, _
- ByVal fx2 As Integer, ByVal fy2 As Integer, _
- ByVal tx1 As Integer, ByVal ty1 As Integer, _
- ByVal tx2 As Integer, ByVal ty2 As Integer)
- Dim bm As BITMAP
- Dim hbm As Integer
- Dim status As Long
- Dim from_bytes() As Byte
- Dim to_bytes() As Byte
- Dim from_wid As Long
- Dim from_hgt As Long
- Dim to_wid As Long
- Dim to_hgt As Long
- Dim xscale As Single
- Dim yscale As Single
- Dim tx As Integer
- Dim ty As Integer
- Dim fx As Single
- Dim fy As Single
- Dim ifx As Single
- Dim ify As Single
- Dim dx As Single
- Dim dy As Single
- Dim c1 As Integer
- Dim c2 As Integer
- Dim c3 As Integer
- Dim c4 As Integer
- Dim i1 As Integer
- Dim i2 As Integer
- Dim clr As Integer
- ' Compute the scaling parameters.
- xscale = (tx2 - tx1) / (fx2 - fx1)
- yscale = (ty2 - ty1) / (fy2 - fy1)
- ' Get from_pic's pixels.
- hbm = from_pic.Image
- status = GetObject(hbm, BITMAP_SIZE, bm)
- from_wid = bm.bmWidthBytes
- from_hgt = bm.bmHeight
- ReDim from_bytes(0 To from_wid - 1, 0 To from_hgt - 1)
- status = GetBitmapBits(hbm, from_wid * from_hgt, from_bytes(0, 0))
- ' Get to_pic's pixels.
- hbm = to_pic.Image
- status = GetObject(hbm, BITMAP_SIZE, bm)
- to_wid = bm.bmWidthBytes
- to_hgt = bm.bmHeight
- ReDim to_bytes(0 To to_wid - 1, 0 To to_hgt - 1)
- status = GetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
-
- ' Perform the enlargement.
- For ty = ty1 To ty2
- fy = (ty - ty1) / yscale + fy1
- ify = Int(fy)
- dy = fy - ify
- For tx = tx1 To tx2
- fx = (tx - tx1) / xscale + fx1
- ifx = Int(fx)
- dx = fx - ifx
- ' Interpolate using the four nearest
- ' pixels in from_pic.
- c1 = palentry(from_bytes(ifx, ify)).peRed
- c2 = palentry(from_bytes(ifx + 1, ify)).peRed
- c3 = palentry(from_bytes(ifx, ify + 1)).peRed
- c4 = palentry(from_bytes(ifx + 1, ify + 1)).peRed
- ' Interpolate in the Y direction.
- i1 = c1 * (1 - dy) + c3 * dy
- i2 = c2 * (1 - dy) + c4 * dy
- ' Interpolate the results in the X direction.
- clr = i1 * (1 - dx) + i2 * dx
- to_bytes(tx, ty) = NearestNonstaticGray(clr)
- Next tx
- Next ty
- ' Update from_pic.
- status = SetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
- to_pic.Refresh
- End Sub
- ' ***********************************************
- ' Load the control's palette so the non-static
- ' colors are grays. Map the logical palette to
- ' match the system palette. Convert the image to
- ' use the non-static grays.
- ' Set the following module global variables.
- ' LogPal Image logical palette handle.
- ' palentry() Image logical palette entries.
- ' wid Width of image.
- ' hgt Height of image.
- ' bytes(1 To wid, 1 To hgt)
- ' Image pixel values.
- ' ***********************************************
- Sub MatchGrayPalette(pic As Control)
- Dim sys(0 To 255) As PALETTEENTRY
- Dim i As Integer
- Dim bm As BITMAP
- Dim hbm As Integer
- Dim status As Long
- Dim X As Integer
- Dim Y As Integer
- Dim gray As Single
- Dim dgray As Single
- Dim c As Integer
- Dim clr As Integer
- ' Make sure pic has the foreground palette.
- pic.ZOrder
- i = RealizePalette(pic.hdc)
- DoEvents
- ' Get the system palette entries.
- i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))
-
- ' Get the image pixels.
- hbm = pic.Image
- status = GetObject(hbm, BITMAP_SIZE, bm)
- wid = bm.bmWidthBytes
- hgt = bm.bmHeight
- ReDim bytes(1 To wid, 1 To hgt)
- status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
- ' Make the logical palette as big as possible.
- LogPal = pic.Picture.hPal
- If ResizePalette(LogPal, SysPalSize) = 0 Then
- Beep
- MsgBox "Error resizing logical palette.", _
- vbExclamation
- Exit Sub
- End If
- ' Blank the non-static colors.
- For i = 0 To StaticColor1
- palentry(i) = sys(i)
- Next i
- For i = StaticColor1 + 1 To StaticColor2 - 1
- With palentry(i)
- .peRed = 0
- .peGreen = 0
- .peBlue = 0
- .peFlags = PC_NOCOLLAPSE
- End With
- Next i
- For i = StaticColor2 To 255
- palentry(i) = sys(i)
- Next i
- i = SetPaletteEntries(LogPal, 0, SysPalSize, palentry(0))
- ' Insert the non-static grays.
- gray = 0
- dgray = 255 / (StaticColor2 - StaticColor1 - 2)
- For i = StaticColor1 + 1 To StaticColor2 - 1
- c = gray
- gray = gray + dgray
- With palentry(i)
- .peRed = c
- .peGreen = c
- .peBlue = c
- End With
- Next i
- i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
- ' Recreate the image using the new colors.
- For Y = 1 To hgt
- For X = 1 To wid
- clr = bytes(X, Y)
- With sys(clr)
- c = (CInt(.peRed) + .peGreen + .peBlue) / 3
- End With
- bytes(X, Y) = NearestNonstaticGray(c)
- Next X
- Next Y
- status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
- ' Realize the gray palette.
- i = RealizePalette(pic.hdc)
- pic.Refresh
- End Sub
- ' ************************************************
- ' Return the index of the nonstatic gray closest
- ' to the given value (assuming the non-static
- ' colors are a gray scale created by
- ' MatchGrayPalette).
- ' ************************************************
- Function NearestNonstaticGray(c As Integer) As Integer
- Dim dgray As Single
- If c < 0 Then
- c = 0
- ElseIf c > 255 Then
- c = 255
- End If
- dgray = 255 / (StaticColor2 - StaticColor1 - 2)
- NearestNonstaticGray = c / dgray + StaticColor1 + 1
- End Function
- Private Sub Form_Load()
- Dim i As Integer
- ' Make sure the screen supports palettes.
- If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
- Beep
- MsgBox "This monitor does not support palettes.", _
- vbCritical
- End
- End If
- ' Get system palette size and # static colors.
- SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
- NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
- StaticColor1 = NumStaticColors \ 2 - 1
- StaticColor2 = SysPalSize - NumStaticColors \ 2
- ' Make the pictures all use gray palettes.
- ScaleFactor = 2
- Me.Show
- DoEvents
- WaitStart
- For i = 1 To 2
- MatchGrayPalette Pict(i)
- Next i
- DoEvents
- ' Let each image repair its palette if needed.
- For i = 0 To 2
- Pict(i).ZOrder
- DoEvents
- Next i
- WaitEnd
- End Sub
- ' ***********************************************
- ' Reset the cursors for the form and all the
- ' picture boxes.
- ' ***********************************************
- Sub WaitEnd()
- Dim i As Integer
- MousePointer = vbDefault
- For i = 0 To 2
- Pict(i).MousePointer = vbDefault
- Next i
- End Sub
- ' ***********************************************
- ' Give the form and all the picture boxes an
- ' hourglass cursor.
- ' ***********************************************
- Sub WaitStart()
- Dim i As Integer
- MousePointer = vbHourglass
- For i = 0 To 2
- Pict(i).MousePointer = vbHourglass
- Next i
- DoEvents
- End Sub
- Private Sub Form_Unload(Cancel As Integer)
- End
- End Sub
- Private Sub mnuFileExit_Click()
- Unload Me
- End Sub
- ' ***********************************************
- ' Load a new image file.
- ' ***********************************************
- Private Sub mnuFileLoad_Click()
- Dim fname As String
- ' Allow the user to pick a file.
- On Error Resume Next
- FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
- FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
- FileDialog.ShowOpen
- If Err.Number = cdlCancel Then
- Exit Sub
- ElseIf Err.Number <> 0 Then
- Beep
- MsgBox "Error selecting file.", , vbExclamation
- Exit Sub
- End If
- On Error GoTo 0
- fname = Trim$(FileDialog.filename)
- FileDialog.InitDir = Left$(fname, Len(fname) _
- - Len(FileDialog.FileTitle) - 1)
- ' Load the picture.
- WaitStart
- LoadFromPict fname
- mnuScaleMnu.Enabled = True
- mnuScale_Click 2
- WaitEnd
- End Sub
- ' ***********************************************
- ' Load the indicated file and prepare to work
- ' with its palette.
- ' ***********************************************
- Sub LoadFromPict(fname As String)
- Dim status As Long
- On Error GoTo LoadFileError
- Pict(0).Picture = LoadPicture(fname)
- On Error GoTo 0
-
- MatchGrayPalette Pict(0)
- Caption = "Enlarge [" & fname & "]"
- Exit Sub
- LoadFileError:
- Beep
- MsgBox "Error loading file " & fname & "." & _
- vbCrLf & Error$
- Exit Sub
- End Sub
- ' ************************************************
- ' Redraw the images at the new scale.
- ' ************************************************
- Private Sub mnuScale_Click(Index As Integer)
- mnuScale(ScaleFactor).Checked = False
- ScaleFactor = Index
- mnuScale(ScaleFactor).Checked = True
- DrawImages
- End Sub
-